home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Best of Shareware
/
Best of PC Windows Shareware 1.0 - Wayzata Technology (7111) (1993).iso
/
mac
/
ZIPPED
/
DOS
/
PROGRAMG
/
FORTHCMP.ZIP
/
FORTHLIB.SCR
< prev
next >
Wrap
Text File
|
1992-03-30
|
11KB
|
1 lines
\ FORTH COMPILER FORTH-83 LIBRARY 09:29 12/30/91 COPYRIGHT 1985 (C) BY THOMAS ALMY. ALL RIGHTS RESERVED Permission is granted to registered users of ForthCMP to sell or distribute computer programs incorporating the compiled contents of this file. SKIP AND SCAN ARE FROM LAXEN & PERRY FORTH 83. MS is a trademark of Microsoft Corporation. \ INPUT WORDS 18:59 08/14/87 CR .( LOADING FORTHLIB ) CR HEX FORTH U: #IN PAD DUP 52 BL FILL DUP 50 EXPECT 1- NUMBER? 0= IF 0 ( error ) ELSE DROP THEN ; UNDEF NUMBER? FIND DPL 0= #IF VARIABLE DPL #ELSE DROP #THEN : NUMBER? 0. ROT DUP 1+ C@ ASCII - = IF 1+ -1 ELSE 0 THEN >R -1 BEGIN DPL ! CONVERT DUP C@ BL > WHILE DUP C@ ASCII . <> IF R> DROP DROP 0 EXIT THEN 0 REPEAT DROP R> IF DNEGATE THEN -1 ; #THEN UNDEF CONVERT FIND DPL 0= #IF VARIABLE DPL #ELSE DROP #THEN : CONVERT BEGIN 1+ DUP >R C@ ASCII 0 - DUP 0< IF 0 ELSE DUP 9 > IF 7 - THEN DUP BASE @ < THEN WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ DPL @ 0< NOT IF 1 DPL +! THEN R> REPEAT DROP R> ; #THEN --> ( INPUT WORDS 22:31 04/22/85 ) U: WORD >R #TIB @ >IN @ MIN DUP TIB + #TIB @ ROT - OVER SWAP R@ SKIP OVER SWAP R> SCAN DROP 2DUP SWAP - >R ROT - 1+ >IN @ + #TIB @ MIN >IN ! R@ DP @ C! DP @ 1+ R> CMOVE DP @ DUP COUNT + 20 C<- ; UNDEF SKIP ASM L: done CX PUSH BX JMPI CODE SKIP BX POP AX POP CX POP done LOOP ~ JMPC DI POP DX DS <SEG DX ES >SEG REPZ BYTE SCAS =0 ~ IF, CX INC DI DEC THEN, DI PUSH CX PUSH BX JMPI END-CODE #THEN UNDEF SCAN FIND done 0= #IF ASM L: done CX PUSH BX JMPI #ELSE DROP #THEN CODE SCAN BX POP AX POP CX POP done LOOP ~ JMPC DI POP DX DS <SEG DX ES >SEG REPNZ BYTE SCAS =0 IF, CX INC DI DEC THEN, DI PUSH CX PUSH BX JMPI END-CODE #THEN --> \ DOUBLE NUMBER SUPPORT 16:39 09/15/87 U: QUERY TIB 50 EXPECT SPAN @ #TIB ! >IN OFF ; U: DMIN 2OVER 2OVER D< NOT IF 2SWAP THEN 2DROP ; U: DMAX 2OVER 2OVER D< IF 2SWAP THEN 2DROP ; PRIMITIVE U: D< ROT SWAP 2DUP <> IF < -ROT 2DROP ELSE 2DROP U< THEN ; U: DU< ROT SWAP 2DUP <> IF 2SWAP THEN 2DROP U< ; UNDEF 2SWAP CODE 2SWAP SI POP AX POP BX POP CX POP DX POP BX PUSH AX PUSH DX PUSH CX PUSH SI JMPI END-CODE #THEN U: 2ROT 5 ROLL 5 ROLL ; PRIMITIVE U: D= ROT = >R = R> AND ; U: D. 0 D.R SPACE ; U: D.R >R TUCK DABS <# #S ROT SIGN #> R> OVER - SPACES TYPE ; --> \ FORMATTED OUTPUT FUNCTIONS 19:52 04/20/87 UNDEF D2/ CODE D2/ AX 1 SAR BX 1 RCR RET END-CODE #THEN U: DABS DUP 0< IF DNEGATE THEN ; U: (.") CS: COUNT 2DUP + -ROT CS:TYPE ; PRIMITIVE U: HEX 10 BASE ! ; PRIMITIVE U: DECIMAL 0A BASE ! ; U: U. 0 <# #S #> TYPE SPACE ; U: U.R >R 0 <# #S #> R> OVER - SPACES TYPE ; U: . DUP ABS 0 <# #S ROT SIGN #> TYPE SPACE ; U: .R >R DUP ABS 0 <# #S ROT SIGN #> R> OVER - SPACES TYPE ; U: SPACES DUP 0> IF 0 DO SPACE LOOP EXIT THEN DROP ; FIND EMIT ?DUP #IF ?DEFINE CS:TYPE #IF SEPDSEG? #IF : CS:TYPE 0 ?DO CS: COUNT EMIT LOOP DROP ; #ELSE CODE CS:TYPE END-CODE REQUIRE TYPE #THEN #THEN U: TYPE 0 ?DO COUNT EMIT LOOP DROP ; #THEN --> ( FORMATTED OUTPUT FUNCTION 07:39 02/01/86 ) U: SPACE 20 EMIT ; U: #S BEGIN # 2DUP OR 0= UNTIL ; U: # BASE @ MU/MOD ROT 9 OVER < IF 7 + THEN 30 + HOLD ; U: MU/MOD >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; U: SIGN 0< IF 2D HOLD THEN ; UNDEF HOLD FIND HLD #IF DROP #ELSE VARIABLE HLD #THEN : HOLD -1 HLD +! HLD @ C! ; #THEN U: #> 2DROP HLD @ PAD OVER - ; U: <# PAD HLD ! ; UNDEF -TRAILING CODE -TRAILING AX CX MOV BX AX MOV LOOP IF, CX BX ADD BX DEC BEGIN, 20 # [BX] BYTE CMP =0 IF, BX DEC SWAP LOOP ~ UNTIL, THEN, AX BX MOV THEN, CX AX MOV RET END-CODE #THEN --> \ DEPTH ALLOT HERE PAD C, , 16:38 09/15/87 UNDEF DEPTH CODE DEPTH S0 [] AX MOV SP AX SUB AX 1 SAR RET END-CODE #THEN U: ALLOT DP +! ; U: HERE DP @ ; U: PAD DP @ 64 + ; U: C, DP @ C! 1 DP +! ; U: , DP @ ! 2 DP +! ; --> \ CMOVE> FILL ROLL DNEGATE SPAN EXPECT 13:52 01/03/92 UNDEF CMOVE> CODE CMOVE> BX POP CX POP DI POP SI POP CX AX MOV AX DEC AX SI ADD AX DI ADD STD AX DS <SEG AX ES >SEG REPZ BYTE MOVS CLD BX JMPI END-CODE #THEN UNDEF FILL CODE FILL BX POP AX POP CX POP DI POP DX DS <SEG DX ES >SEG REPZ BYTE STOS BX JMPI END-CODE #THEN UNDEF ROLL CODE ROLL BX POP DI POP AX SS <SEG AX ES >SEG DI CX MOV CX INC DI 1 SHL SP DI ADD DI SI MOV SI DEC SI DEC SS: [DI] PUSH STD CLI REPZ MOVS STI CLD SP INC SP INC BX JMPI END-CODE #THEN UNDEF DNEGATE CODE DNEGATE AX NOT BX NOT 1 # BX ADD 0 # AX ADC RET END-CODE #THEN UNDEF EXPECT FIND SPAN #IF DROP #ELSE VARIABLE SPAN #THEN : EXPECT ( ADDR LEN -- ) 80 ! 80 0A BDOS DROP 81 C@ SPAN ! 82 SWAP SPAN @ CMOVE CR ; #THEN --> ( DOS INTERFACE 19:34 09/06/86 ) U: KEY 0 8 BDOS ; U: ?TERMINAL 0 0B BDOS 0<> ; U: CR 0D EMIT 0A EMIT ; ?DEFINE EMIT ?DEFINE TYPE ?DEFINE CS:TYPE ?DEFINE CONSOLE ?DEFINE PRINTER ?DEFINE MESSAGES OR OR OR OR OR #IF VARIABLE of DSEG 1 of ! #THEN UNDEF EMIT HERE 1 ALLOT CODE EMIT AL OVER [] MOV 40 # AH MOV 1 # CX MOV DUP # DX MOV of [] BX MOV 21 INT RET END-CODE DROP #THEN UNDEF CS:TYPE CODE CS:TYPE SEPDSEG? #IF AX CX MOV BX DX MOV of [] BX MOV DS PUSHSEG AX CS <SEG AX DS >SEG 40 # AH MOV 21 INT DS POPSEG RET #ELSE REQUIRE TYPE #THEN END-CODE #THEN UNDEF TYPE CODE TYPE AX CX MOV BX DX MOV of [] BX MOV 40 # AH MOV 21 INT RET END-CODE #THEN UNDEF CONSOLE CODE CONSOLE 1 # of [] MOV RET END-CODE #THEN UNDEF PRINTER CODE PRINTER 4 # of [] MOV RET END-CODE #THEN UNDEF MESSAGES CODE MESSAGES 2 # of [] MOV RET END-CODE #THEN -->\ DOS INTERFACE CMOVEs 2OVER */MOD 2 16:22 12/15/91 UNDEF BDOS CODE BDOS AL AH MOV BX DX MOV 21 INT AH AH XOR RET END-CODE #THEN UNDEF BYE CODE BYE ' bye JMP END-CODE #THEN UNDEF RETURN CODE RETURN AX POP AX POP 4C # AH MOV 21 INT END-CODE #THEN UNDEF CMOVE CODE CMOVE BX POP CX POP DI POP SI POP AX DS <SEG AX ES >SEG REPZ BYTE MOVS BX JMPI END-CODE #THEN UNDEF CMOVEL CODE CMOVEL BX POP CX POP DI POP ES POPSEG SI POP DX DS <SEG DS POPSEG REPZ BYTE MOVS DX DS >SEG BX JMPI END-CODE #THEN PRIMITIVE U: 2OVER 3 PICK 3 PICK ; U: */MOD >R M* R> M/MOD ; --> ( {do}s 21:49 09/06/86 ) UNDEF (do) CODE (do) 8000 # DX MOV AX DX SUB CX DX ADD BP DEC BP DEC DX [BP] MOV RET #THEN UNDEF (?do) CODE (?do) 8000 # DX MOV AX DX SUB CX DX ADD BP DEC BP DEC DX [BP] MOV AX CX CMP RET #THEN
